home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp.lbr / XLSUBR.CQ / xlsubr.c
Encoding:
C/C++ Source or Header  |  1985-06-03  |  14.8 KB  |  581 lines
  1.                      /* xlsubr - xlisp builtin functions */
  2. #ifdef CI_86
  3. #include "a:stdio.h"
  4. #include "xlisp.h"
  5. #endif
  6.  
  7. #ifdef AZTEC
  8. #include "a:stdio.h"
  9. #include "xlisp.h"
  10. #endif
  11.  
  12. #ifdef unix
  13. #include <stdio.h>
  14. #include <xlisp.h>
  15. #endif
  16.  
  17.  
  18.                             /* external variables */
  19.  
  20. extern int (*xlgetc)();
  21. extern struct node *xlstack;
  22.  
  23.  
  24.                               /* local variables */
  25.  
  26. static char *sgetptr;
  27.  
  28.  
  29.                     /***************************************
  30.                     *  xlsubr - define a builtin function  *
  31.                     ***************************************/
  32.  
  33. xlsubr(sname,subr)
  34.   char *sname; struct node *(*subr)();
  35. {
  36.     struct node *sym;
  37.  
  38.     sym = xlenter(sname);              /* Enter the symbol */
  39.  
  40.     sym->n_symvalue = newnode(SUBR);   /* Initialize the value */
  41.     sym->n_symvalue->n_subr = subr;
  42. }
  43.  
  44.  
  45.                  /**********************************************
  46.                  *  xlsvar - define a builtin string variable  *
  47.                  **********************************************/
  48.  
  49. xlsvar(sname,str)
  50.   char *sname,*str;
  51. {
  52.     struct node *sym;
  53.  
  54.     sym = xlenter(sname);              /* Enter the symbol */
  55.  
  56.     sym->n_symvalue = newnode(STR);    /* Initialize the value */
  57.     sym->n_symvalue->n_str = strsave(str);
  58. }
  59.  
  60.  
  61.                        /**********************************
  62.                        *  xlarg - get the next argument  *
  63.                        **********************************/
  64.  
  65. struct node *xlarg(pargs)
  66.   struct node **pargs;
  67. {
  68.     struct node *arg;
  69.  
  70.     if (*pargs == NULL)                /* Does argument exist ? */
  71.         xlfail("too few arguments");
  72.  
  73.     arg = (*pargs)->n_listvalue;       /* If so get its value */
  74.     *pargs = (*pargs)->n_listnext;     /* and mov arg pointer ahead */
  75.  
  76.     return (arg);
  77. }
  78.  
  79.  
  80.                /*************************************************
  81.                *  xlmatch - get an argument and match its type  *
  82.                *************************************************/
  83.  
  84. struct node *xlmatch(type,pargs)
  85.   int type; struct node **pargs;
  86. {
  87.     struct node *arg;
  88.  
  89.     arg = xlarg(pargs);                /* Get the argument */
  90.     if (type == LIST)                  /* Check its type */
  91.     {
  92.         if (arg != NULL && arg->n_type != LIST)
  93.             xlfail("bad argument type");
  94.     }
  95.     else
  96.     {
  97.         if (arg == NULL || arg->n_type != type)
  98.             xlfail("bad argument type");
  99.     }
  100.  
  101.     return (arg);
  102. }
  103.  
  104.  
  105.               /****************************************************
  106.               *  xlevarg - get the next argument and evaluate it  *
  107.               ****************************************************/
  108.  
  109. struct node *xlevarg(pargs)
  110.   struct node **pargs;
  111. {
  112.     struct node *oldstk,val;
  113.  
  114.     oldstk = xlsave(&val,NULL);        /* Creat new stack frame */
  115.  
  116.     val.n_ptr = xlarg(pargs);          /* Get and evaluate the argument */
  117.     val.n_ptr = xleval(val.n_ptr);
  118.  
  119.     xlstack = oldstk;                  /* Restore old stack frame */
  120.     return (val.n_ptr);
  121. }
  122.  
  123.  
  124.          /*************************************************************
  125.          *  xlevmatch - get an evaluated argument and match its type  *
  126.          *************************************************************/
  127.  
  128. struct node *xlevmatch(type,pargs)
  129.   int type; struct node **pargs;
  130. {
  131.     struct node *arg;
  132.  
  133.     arg = xlevarg(pargs);              /* Get argument and check type */
  134.     if (type == LIST)
  135.     {
  136.         if (arg != NULL && arg->n_type != LIST)
  137.             xlfail("bad argument type");
  138.     }
  139.     else
  140.     {
  141.         if (arg == NULL || arg->n_type != type)
  142.             xlfail("bad argument type");
  143.     }
  144.  
  145.     return (arg);
  146. }
  147.  
  148.  
  149.      /**********************************************************************
  150.      *  xllastarg - make sure the remainder of the argument list is empty  *
  151.      **********************************************************************/
  152.  
  153. xllastarg(args)
  154.   struct node *args;
  155. {
  156.     if (args != NULL)
  157.         xlfail("too many arguments");
  158. }
  159.  
  160.  
  161.                     /****************************************
  162.                     *  assign - assign a value to a symbol  *
  163.                     ****************************************/
  164.  
  165. static assign(sym,val)
  166.   struct node *sym,*val;
  167. {
  168.     struct node *lptr;
  169.  
  170.     if ((lptr = xlobsym(sym)) != NULL)      /* Check for a current object */
  171.         lptr->n_listvalue = val;
  172.     else
  173.         sym->n_symvalue = val;
  174. }
  175.  
  176.  
  177.                         /*******************************
  178.                         *  set - builtin function set  *
  179.                         *******************************/
  180.  
  181. static struct node *set(args)
  182.   struct node *args;
  183. {
  184.     struct node *oldstk,arg,sym,val;
  185.  
  186.     oldstk = xlsave(&arg,&sym,&val,NULL);   /* Create new stack frame */
  187.     arg.n_ptr = args;
  188.  
  189.     sym.n_ptr = xlevmatch(SYM,&arg.n_ptr);  /* Get symbol */
  190.     val.n_ptr = xlevarg(&arg.n_ptr);
  191.     xllastarg(arg.n_ptr);
  192.     assign(sym.n_ptr,val.n_ptr);
  193.  
  194.     xlstack = oldstk;                       /* Restore old stack frame */
  195.     return (val.n_ptr);
  196. }
  197.  
  198.  
  199.                        /*********************************
  200.                        *  setq - builtin function setq  *
  201.                        *********************************/
  202.  
  203. static struct node *setq(args)
  204.   struct node *args;
  205. {
  206.     struct node *oldstk,arg,sym,val;
  207.  
  208.     oldstk = xlsave(&arg,&sym,&val,NULL);   /* Create new stack frame */
  209.     arg.n_ptr = args;
  210.  
  211.     sym.n_ptr = xlmatch(SYM,&arg.n_ptr);     /* get symbol */
  212.     val.n_ptr = xlevarg(&arg.n_ptr);
  213.     xllastarg(arg.n_ptr);
  214.     assign(sym.n_ptr,val.n_ptr);
  215.  
  216.     xlstack = oldstk;                       /* Restore old stack frame */
  217.     return (val.n_ptr);
  218. }
  219.  
  220.  
  221.                       /************************************
  222.                       *  load - direct input from a file  *
  223.                       ************************************/
  224.  
  225. static struct node *load(args)
  226.   struct node *args;
  227. {
  228.     struct node *fname;
  229.  
  230.     fname = xlevmatch(STR,&args);           /* Get file name */
  231.     xllastarg(args);
  232.  
  233.     xlfin(fname->n_str);
  234.  
  235.     return (fname);
  236. }
  237.  
  238.  
  239.                       /***********************************
  240.                       *  defun - builtin function defun  *
  241.                       ***********************************/
  242.  
  243. static struct node *defun(args)
  244.   struct node *args;
  245. {
  246.     struct node *oldstk,arg,sym,fargs,fun;
  247.  
  248.     /* create a new stack frame */
  249.     oldstk = xlsave(&arg,&sym,&fargs,&fun,NULL);
  250.  
  251.     /* initialize */
  252.     arg.n_ptr = args;
  253.  
  254.     /* get the function symbol */
  255.     sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
  256.  
  257.     /* get the formal argument list */
  258.     fargs.n_ptr = xlmatch(LIST,&arg.n_ptr);
  259.  
  260.     /* create a new function definition */
  261.     fun.n_ptr = newnode(LIST);
  262.     fun.n_ptr->n_listvalue = fargs.n_ptr;
  263.     fun.n_ptr->n_listnext = arg.n_ptr;
  264.  
  265.     /* make the symbol point to a new function definition */
  266.     assign(sym.n_ptr,fun.n_ptr);
  267.  
  268.     /* restore the previous stack frame */
  269.     xlstack = oldstk;
  270.  
  271.     /* return the function symbol */
  272.     return (sym.n_ptr);
  273. }
  274.  
  275.  
  276.                    /******************************************
  277.                    *  sgetc - get a character from a string  *
  278.                    ******************************************/
  279.  
  280. static int sgetc()
  281. {
  282.     if (*sgetptr == 0)
  283.         return (-1);
  284.     else
  285.         return (*sgetptr++);
  286. }
  287.  
  288.  
  289.                          /******************************
  290.                          *  read - read an expression  *
  291.                          ******************************/
  292.  
  293. static struct node *read(args)
  294.   struct node *args;
  295. {
  296.     struct node *val;
  297.     int (*oldgetc)();
  298.  
  299.     /* save the old input stream */
  300.     oldgetc = xlgetc;
  301.  
  302.     /* get the string or file pointer */
  303.     if (args != NULL) {
  304.         sgetptr = xlevmatch(STR,&args)->n_str;
  305.         xlgetc = sgetc;
  306.     }
  307.  
  308.     /* make sure there aren't any more arguments */
  309.     xllastarg(args);
  310.  
  311.     val = xlread();
  312.     xlgetc = oldgetc;
  313.  
  314.     return (val);
  315. }
  316.  
  317.  
  318.                       /************************************
  319.                       *  fwhile - builtin function while  *
  320.                       ************************************/
  321.  
  322. static struct node *fwhile(args)
  323.   struct node *args;
  324. {
  325.     struct node *oldstk,farg,arg,*val;
  326.  
  327.     /* create a new stack frame */
  328.     oldstk = xlsave(&farg,&arg,NULL);
  329.  
  330.     /* initialize */
  331.     farg.n_ptr = arg.n_ptr = args;
  332.  
  333.     /* loop until test fails */
  334.     val = NULL;
  335.     for (; TRUE; arg.n_ptr = farg.n_ptr) {
  336.  
  337.         /* evaluate the test expression */
  338.         if (!testvalue(xlevarg(&arg.n_ptr)))
  339.             break;
  340.  
  341.         /* evaluate each remaining argument */
  342.         while (arg.n_ptr != NULL)
  343.             val = xlevarg(&arg.n_ptr);
  344.     }
  345.  
  346.     /* restore the previous stack frame */
  347.     xlstack = oldstk;
  348.  
  349.     /* return the last test expression value */
  350.     return (val);
  351. }
  352.  
  353.  
  354.                      /**************************************
  355.                      *  frepeat - builtin function repeat  *
  356.                      **************************************/
  357.  
  358. static struct node *frepeat(args)
  359.   struct node *args;
  360. {
  361.     struct node *oldstk,farg,arg,*val;
  362.     int cnt;
  363.  
  364.     /* create a new stack frame */
  365.     oldstk = xlsave(&farg,&arg,NULL);
  366.  
  367.     /* initialize */
  368.     arg.n_ptr = args;
  369.  
  370.     cnt = xlevmatch(INT,&arg.n_ptr)->n_int;
  371.  
  372.     /* save the first expression to repeat */
  373.     farg.n_ptr = arg.n_ptr;
  374.  
  375.     /* loop until test fails */
  376.     val = NULL;
  377.     for (; cnt > 0; cnt--) {
  378.  
  379.         /* evaluate each remaining argument */
  380.         while (arg.n_ptr != NULL)
  381.             val = xlevarg(&arg.n_ptr);
  382.  
  383.         /* restore pointer to first expression */
  384.         arg.n_ptr = farg.n_ptr;
  385.     }
  386.  
  387.     /* restore the previous stack frame */
  388.     xlstack = oldstk;
  389.  
  390.     /* return the last test expression value */
  391.     return (val);
  392. }
  393.  
  394.  
  395.                     /***************************************
  396.                     *  foreach - builtin function foreach  *
  397.                     ***************************************/
  398.  
  399. static struct node *foreach(args)
  400.   struct node *args;
  401. {
  402.     struct node *oldstk,arg,sym,list,code,oldbnd,*val;
  403.  
  404.     /* create a new stack frame */
  405.     oldstk = xlsave(&arg,&sym,&list,&code,&oldbnd,NULL);
  406.  
  407.     /* initialize */
  408.     arg.n_ptr = args;
  409.  
  410.     /* get the symbol to bind to each list element */
  411.     sym.n_ptr = xlmatch(SYM,&arg.n_ptr);
  412.  
  413.     /* save the old binding of the symbol */
  414.     oldbnd.n_ptr = sym.n_ptr->n_symvalue;
  415.  
  416.     /* get the list to iterate over */
  417.     list.n_ptr = xlevmatch(LIST,&arg.n_ptr);
  418.  
  419.     /* save the pointer to the code */
  420.     code.n_ptr = arg.n_ptr;
  421.  
  422.     /* loop until test fails */
  423.     val = NULL;
  424.     while (list.n_ptr != NULL) {
  425.  
  426.         /* check the node type */
  427.         if (list.n_ptr->n_type != LIST)
  428.             xlfail("bad node type in list");
  429.  
  430.         /* bind the symbol to the list element */
  431.         sym.n_ptr->n_symvalue = list.n_ptr->n_listvalue;
  432.  
  433.         /* evaluate each remaining argument */
  434.         while (arg.n_ptr != NULL)
  435.             val = xlevarg(&arg.n_ptr);
  436.  
  437.         /* point to the next list element */
  438.         list.n_ptr = list.n_ptr->n_listnext;
  439.  
  440.         /* restore the pointer to the code */
  441.         arg.n_ptr = code.n_ptr;
  442.     }
  443.  
  444.     /* restore the previous stack frame */
  445.     xlstack = oldstk;
  446.  
  447.     /* restore the old binding of the symbol */
  448.     sym.n_ptr->n_symvalue = oldbnd.n_ptr;
  449.  
  450.     /* return the last test expression value */
  451.     return (val);
  452. }
  453.  
  454.  
  455.                          /******************************
  456.                          *  fif - builtin function if  *
  457.                          ******************************/
  458.  
  459. static struct node *fif(args)
  460.   struct node *args;
  461. {
  462.     struct node *oldstk,arg,testexpr,thenexpr,elseexpr,*val;
  463.     int dothen;
  464.  
  465.     /* create a new stack frame */
  466.     oldstk = xlsave(&arg,&testexpr,&thenexpr,&elseexpr,NULL);
  467.  
  468.     /* initialize */
  469.     arg.n_ptr = args;
  470.  
  471.     /* evaluate the test expression */
  472.     testexpr.n_ptr = xlevarg(&arg.n_ptr);
  473.  
  474.     /* get the then clause */
  475.     thenexpr.n_ptr = xlmatch(LIST,&arg.n_ptr);
  476.  
  477.     /* get the else clause */
  478.     if (arg.n_ptr != NULL)
  479.         elseexpr.n_ptr = xlmatch(LIST,&arg.n_ptr);
  480.     else
  481.         elseexpr.n_ptr = NULL;
  482.  
  483.     /* make sure there aren't any more arguments */
  484.     xllastarg(arg.n_ptr);
  485.  
  486.     /* figure out which expression to evaluate */
  487.     dothen = testvalue(testexpr.n_ptr);
  488.  
  489.     /* default the result value to the value of the test expression */
  490.     val = testexpr.n_ptr;
  491.  
  492.     /* evaluate the appropriate clause */
  493.     if (dothen)
  494.         while (thenexpr.n_ptr != NULL)
  495.             val = xlevarg(&thenexpr.n_ptr);
  496.     else
  497.         while (elseexpr.n_ptr != NULL)
  498.             val = xlevarg(&elseexpr.n_ptr);
  499.  
  500.     /* restore the previous stack frame */
  501.     xlstack = oldstk;
  502.  
  503.     /* return the last value */
  504.     return (val);
  505. }
  506.  
  507.  
  508.               /****************************************************
  509.               *  quote - builtin function to quote an expression  *
  510.               ****************************************************/
  511.  
  512. static struct node *quote(args)
  513.   struct node *args;
  514. {
  515.     /* make sure there is exactly one argument */
  516.     if (args == NULL || args->n_listnext != NULL)
  517.         xlfail("incorrect number of arguments");
  518.  
  519.     /* return the quoted expression */
  520.     return (args->n_listvalue);
  521. }
  522.  
  523.  
  524.                          /*****************************
  525.                          *  fexit - get out of xlisp  *
  526.                          *****************************/
  527.  
  528. fexit()
  529. {
  530.     exit();
  531. }
  532.  
  533.  
  534.                 /***********************************************
  535.                 *  testvalue - test a value for true or false  *
  536.                 ***********************************************/
  537.  
  538. static int testvalue(val)
  539.   struct node *val;
  540. {
  541.     /* check for a nil value */
  542.     if (val == NULL)
  543.         return (FALSE);
  544.  
  545.     /* check the value type */
  546.     switch (val->n_type) {
  547.     case INT:
  548.             return (val->n_int != 0);
  549.  
  550.     case STR:
  551.             return (strlen(val->n_str) != 0);
  552.  
  553.     default:
  554.             return (TRUE);
  555.     }
  556. }
  557.  
  558.  
  559.                    /******************************************
  560.                    *  xlinit - xlisp initialization routine  *
  561.                    ******************************************/
  562.  
  563. xlinit()
  564. {
  565.     /* enter a copyright notice into the oblist */
  566.     xlenter("Copyright-1983-by-David-Betz");
  567.  
  568.     /* enter the builtin functions */
  569.     xlsubr("set",set);
  570.     xlsubr("setq",setq);
  571.     xlsubr("load",load);
  572.     xlsubr("read",read);
  573.     xlsubr("quote",quote);
  574.     xlsubr("while",fwhile);
  575.     xlsubr("repeat",frepeat);
  576.     xlsubr("foreach",foreach);
  577.     xlsubr("defun",defun);
  578.     xlsubr("if",fif);
  579.     xlsubr("exit",fexit);
  580. }
  581.